perm filename EXPR.SAI[PNT,HE]5 blob
sn#339110 filedate 1978-03-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 entry
C00004 00003 ! record class declarations: scalar,vector,rot,trans,frame,new_tree,expr
C00007 00004 ! compute_func,uncompute_func,error,ggtoken
C00009 00005 ! arithcode,makecode
C00017 00006 ! procedures exp,term,factor,GTEXPR
C00022 ENDMK
C⊗;
entry;
BEGIN "GTEXPR"
EXTERNAL STRING TOKEN;
REQUIRE "[][]" DELIMITERS;
DEFINE RPTR = [RECORD_POINTER],
RCLASS = [RECORD_CLASS],
CRLF = [('15&'12)],
$AL$ = [FALSE],
$POINTY$ = [TRUE],
SPACE = [" "],
NUMERIC_TYPE = [(2)],
! = [COMMENT],
α = [BEGIN],
β = [END];
REQUIRE "OPDECL.SAI[PNT,HE]" SOURCE_FILE;
REDEFINE #SC=1,#VT=2,#RT=3,#TR=4,#FR=5,#DTYPE=6;
PREset_WITH NULL,"SCALAR","VECTOR","ROT","TRANS","FRAME";
STRING ARRAY $DTYPE[0:5];
DEFINE ID_TYPE = 1,
INT_TYPE = 2,
REAL_TYPE = 3,
OPERATOR_TYPE = 4,
RES_TYPE = 5,
UNDECLARED_TYPE = 0;
external integer procedure decSTR(STRING OP);
define token_class = [tokenclass],token_index=[tokenindex];
! record class declarations: scalar,vector,rot,trans,frame,new_tree,expr;
EXTERNAL RCLASS SCALAR (REAL VALUE);
! value=value of the scalar;
EXTERNAL RCLASS VECTOR (REAL XC,YC,ZC);
! xc,yc,zc=value of the component of the vector along x,y,z axis;
EXTERNAL RCLASS FRAME (STRING PNAME; RPTR (FRAME) DAD,SON,EBRO,YBRO; INTEGER HOWLINKED;
REAL ARRAY XF);
! pname=pname of the frame;
! dad,son,ebro,ybro=pointers to dad,son,elder and younger brother
in frame tree;
! howlinked=kind of affixment(rigid,nonrigid,independent);
! xf=array of values
xf[1:3,1:3]=rotation matrix,
xf[1:3,4]=translation vector,
xf[4,1:3]=0,
xf[4,4]=1,
xf[5,1:3]=rotation angles,
xf[5,4]>0 if angles are valid;
EXTERNAL RCLASS ROT (REAL ARRAY XF);
! xf=array of values (as for frame class);
EXTERNAL RCLASS TRANS(REAL ARRAY XF);
! xf=array of values (as for frame class);
! records not entered in $YMTAB, used for computations;
EXTERNAL RPTR(FRAME) F_YPARK,F_BPARK;
INTERNAL RCLASS TREE(RPTR(SCALAR,VECTOR,TRANS,ROT,FRAME)DATA; INTEGER DTYPE);
RCLASS EXPR ( RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)PTR; INTEGER TYPE; RPTR(EXPR)NEXT);
RPTR (EXPR) PROCEDURE MK_EXPR(RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PTR; INTEGER TYPE);
α RPTR(EXPR)X; X←NEW_RECORD(EXPR);
EXPR:PTR[X]←PTR; EXPR:TYPE[X]←TYPE;
RETURN(X);
β;
INTERNAL RPTR(TREE)PROCEDURE NWTREE(RPTR(SCALAR, VECTOR,ROT,TRANS,FRAME) R; INTEGER T);
α RPTR(TREE) K; K←NEW_RECORD(TREE);
TREE:DATA[K]←R; TREE:DTYPE[K]←T; RETURN(K); β;
REQUIRE "EXPINT.HDR[PNT,HE]" SOURCE_FILE;
! compute_func,uncompute_func,error,ggtoken;
EXTERNAL PROCEDURE GTOKEN(BOOLEAN AGAIN(TRUE));
EXTERNAL INTEGER #TOKEN;
EXTERNAL BOOLEAN STOKEN;
EXTERNAL PROCEDURE ERROR(STRING S1,S2(NULL));
INTEGER PROCEDURE COMPUTE_FUNC(INTEGER I1,I2,I3,I4,I5);
RETURN(((((I1*#DTYPE +I2)*#DTYPE + I3)*#DTYPE) + I4)*#DTYPE +I5);
INTEGER PROCEDURE UNCOMPUTE_FUNC(INTEGER I1,I2);
α INTEGER I;
CASE I2 OF
α [1] I←I1 DIV #DTYPE↑4;
[2] I←(I1 DIV #DTYPE↑3)MOD #DTYPE;
[3] I←(I1 DIV #DTYPE↑2) MOD #DTYPE;
[4] I←(I1 DIV #DTYPE) MOD #DTYPE;
[5] I←I1 MOD #DTYPE;
ELSE ERROR("WRONG FIELD IN UNCOMPPUTE_FUNC PARSER ERROR")
β;
RETURN(I);
β;
define token_ptr=[tokenptr];
internal INTEGER TOKENINDEX,tokenclass;
internal RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) TOKENPTR;
PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α GTOKEN(FLAG);
IF #TOKEN=INT_TYPE OR #TOKEN=REAL_TYPE THEN
α INTEGER I;
TOKENINDEX←#SC;
SCALAR:VALUE[TOKEN_PTR←NEW_RECORD(SCALAR)]←REALSCAN(TOKEN,I);
β
ELSE IF #TOKEN=OPERATOR_TYPE THEN DECSTR(TOKEN);
β;
! arithcode,makecode ;
REQUIRE "⊂⊃⊂⊃" REPLACE_DELIMITERS;
INTEGER PROCEDURE MATINX(INTEGER VAL; INTEGER ARRAY A; INTEGER LB,UB);
α INTEGER L,M,U;
L←LB; U←UB;
DO α M←(U+L)/2;
IF A[M]=VAL THEN RETURN(M)
ELSE IF A[M]>VAL THEN U←M-1
ELSE L←M+1;
β UNTIL L>U;
RETURN(0);
β;
DEFINE OPCODE = ⊂
XX("*", TIMES_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"*")⊃)
XX("*", TIMES_X, #SC, #VT, #VT, ⊂OPSCVT(#1,#2,"*")⊃)
XX("*", TIMES_X, #VT, #SC, #VT, ⊂OPSCVT(#2,#1,"*")⊃)
XX("*", TIMES_X, #RT, #VT, #VT, ⊂OPRTVT(#1,#2)⊃)
XX("*", TIMES_X, #RT, #RT, #RT, ⊂OPRTRT(#1,#2)⊃)
XX("*", TIMES_X, #TR, #VT, #VT, ⊂OPTRVT(#1,#2)⊃)
XX("*", TIMES_X, #TR, #TR, #TR, ⊂OPTRTR(#1,#2)⊃)
XX("*", TIMES_X, #TR, #FR, #FR, ⊂OPTRFR(#1,#2)⊃)
XX("*", TIMES_X, #FR, #FR, #FR, ⊂OPFR(#1,#2)⊃)
XX(".", DOT_X, #VT, #VT, #SC, ⊂OPDOT(#1,#2)⊃)
XX("REL", REL_X, #VT, #FR, #VT, ⊂OPVTFR(#2,#1)⊃)
XX("→", BACKARROW_X, #FR, #FR, #TR, ⊂OPFRFR(#1,#2)⊃)
XX("/", DIVIDE_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"/")⊃)
XX("/", DIVIDE_X, #VT, #SC, #VT, ⊂OPSCVT(#2,#1,"/")⊃)
XX("+", PLUS_X, #SC, 0, #SC, ⊂OPSCAL(#1,NEW_RECORD(SCALAR),"+")⊃)
XX("+", PLUS_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"+")⊃)
XX("+", PLUS_X, #VT, 0, #VT, ⊂OPVET(#1,NEW_RECORD(VECTOR),"+")⊃)
XX("+", PLUS_X, #VT, #VT, #VT, ⊂OPVET(#1,#2,"+")⊃)
XX("+", PLUS_X, #VT, #FR, #FR, ⊂OPFRVT(#1,#2,"+")⊃)
XX("+", PLUS_X, #FR, #VT, #FR, ⊂OPFRVT(#2,#1,"+")⊃)
XX("-", MINUS_X, #SC, 0, #SC, ⊂OPSCAL(NEW_RECORD(SCALAR),#1,"-")⊃)
XX("-", MINUS_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"-")⊃)
XX("-", MINUS_X, #VT, 0, #VT, ⊂OPVET(NEW_RECORD(VECTOR),#1,"-")⊃)
XX("-", MINUS_X, #VT, #VT, #VT, ⊂OPVET(#1,#2,"-")⊃)
XX("-", MINUS_X, #FR, #VT, #FR, ⊂OPFRVT(#2,#1,"-")⊃)
! XX("WRT", WRT_X, ) ;
YY("POS", POS_X, TPOS, #VT, 1, #TR, 0, 0)
YY("POS", POS_X, FPOS, #VT, 1, #FR, 0, 0)
YY("UNIT", UNIT_X, NORMVT, #VT, 1, #VT, 0, 0)
! YY("AXIS", AXIS_X, FAXIS, #VT, 1, #RT, 0, 0) ;
! YY("ORIENT", ORIENT_X, FORIENT,#RT, 1, #TR, 0, 0) ;
! YY("REL", REL_X, RELVT, #VT, 2, #VT, #FR, 0) ;
! YY("REL", REL_X, RELFR, #FR, 2, #FR, #TR, 0) ;
! YY("WRT", WRT_X, WRTVT, #VT, 2, #VT, #FR, 0) ;
YY("ORIENT", ORIENT_X, FORIEN, #RT, 1, #FR, 0, 0)
YY("CONSTRUCT", CONSTRUCT_X, CONSV, #FR, 3, #VT, #VT, #VT)
YY("CONSTRUCT", CONSTRUCT_X, CONSF, #FR, 3, #FR, #FR, #FR)
YY("FRAME", FRAME_X, FMAKE, #FR, 2, #RT, #VT, 0)
YY("VECTOR", VECTOR_X, VMAKE, #VT, 3, #SC, #SC, #SC)
YY("TRANS", TRANS_X, TMAKE, #TR, 2, #RT, #VT, 0)
YY("MAGNITUDE", MAGNITUDE_X, SMOD, #SC, 1, #SC, 0, 0)
YY("MAGNITUDE", MAGNITUDE_X, VMOD, #SC, 1, #VT, 0, 0)
! YY("MAGNITUDE", MAGNITUDE_X, RMOD, #SC, 1, #RT, 0, 0) ;
YY("IMPLICIT", IMPLICIT_X, VMAKE, #VT, 3, #SC, #SC, #SC)
YY("IMPLICIT", IMPLICIT_X, RMAKE, #RT, 2, #VT, #SC, 0)
YY("IMPLICIT", IMPLICIT_X, TMAKE, #TR, 2, #RT, #VT, 0)
YY("ROT", ROT_X, RMAKE, #RT, 2, #VT, #SC, 0)
⊃;
REDEFINE XXCOUNT=0;
redefine XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) = ⊂
REDEFINE XXCOUNT=XXCOUNT+1;
REDEFINE XX_VAL=((op_type*#dtype + type1)* #dtype + type2)*#DTYPE*#DTYPE;
XX_VAL ,⊃;
redefine YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#N,#1,#2,#3) = ⊂
REDEFINE XXCOUNT=XXCOUNT+1;
REDEFINE XX_VAL=(((op_type*#dtype + #1)* #dtype + #2)*#dtype + #3)*#DTYPE ;
REDEFINE XX_TEMP=⊂XX_VAL ,⊃;
XX_TEMP ⊃;
preset_array(OCODE, OPCODE, INTEGER, 1, XXCOUNT);
RPTR(EXPR) PROCEDURE MAKE_CODE(INTEGER $$$$, NARG; RPTR(EXPR)R1);
α RPTR(EXPR)R3,x2; INTEGER PP,I; INTEGER ARRAY Q[1:4];
REDEFINE YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#n,#1,#2,#3) = ⊂
redefine xx_temp = ⊂
CASEC #n OFC
⊂;R3←MK_EPXR(OP_FUNC,OP_DTYPE,NULL_RECORD)⊃,
⊂;R3←MK_EXPR(OP_FUNC(EXPR:PTR[R1]),OP_DTYPE)⊃,
⊂;R3←MK_EXPR(OP_FUNC(EXPR:PTR[R1],EXPR:PTR[EXPR:NEXT[R1]]),OP_DTYPE)⊃,
⊂;R3←MK_EXPR(OP_FUNC(EXPR:PTR[R1],EXPR:PTR[EXPR:NEXT[R1]],
EXPR:PTR[EXPR:NEXT[EXPR:NEXT[R1]]]),OP_DTYPE)⊃,
⊂;REQUIRE " HAH" MESSAGE;⊃ ENDC
⊃;
xx_temp ⊃;
REDEFINE XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) =
⊂ redefine #1 = ⊂EXPR:PTR[R1]⊃ ;
redefine #2 = ⊂EXPR:PTR[EXPR:NEXT[R1]]⊃ ;
redefine xx_temp = ⊂
IFC (#SC≤TYPE3≤#FR) THENC
; R3←MK_EXPR(FUNC,TYPE3)
ELSEC ; REQUIRE " HAH " MESSAGE; ENDC ⊃;
xx_temp ⊃;
X2←R1;
FOR I←1 STEP 1 UNTIL NARG MIN 4 DO
BEGIN Q[I]←EXPR:TYPE[X2]; X2←EXPR:NEXT[X2]; END;
FOR I← NARG+1 MIN 5 STEP 1 UNTIL 4 DO Q[I]←0;
PP←COMPUTE_FUNC($$$$,Q[1],Q[2],Q[3],Q[4]);
I←MATINX(PP,OCODE,1,XXCOUNT);
CASE I OF
BEGIN
ERROR(CODE_OP[$$$$]&" cannot take argument(s) type(s) "&
$DTYPE[Q[1]]&" "&$DTYPE[Q[2]]&" "&$DTYPE[Q[3]]&" "&$DTYPE[Q[4]])
OPCODE
END;
return(R3);
β;
! procedures exp,term,factor,GTEXPR;
! E: {+|-} T {+|- T }
T: F {*|/ F}
F: ( E ),
f( , , ...)
<constant>,
<id>, ;
! EXP E: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> ;
FORWARD RECURSIVE RPTR(EXPR)PROCEDURE TERM;
FORWARD RECURSIVE RPTR(EXPR)PROCEDURE FACTOR;
! EXP E: {+|-} T {+|- T } ;
RECURSIVE RPTR(EXPR) PROCEDURE EXP;
α RPTR(EXPR) $$1; INTEGER I;
IF #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP THEN
α I←TOKEN_INDEX;
GGTOKEN; $$1←TERM;
$$1←MAKE_CODE(I,1,$$1);
β
ELSE $$1←TERM;
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP DO
α I←TOKEN_INDEX;
GGTOKEN; EXPR:NEXT[$$1]←TERM;
$$1←MAKE_CODE(I,2,$$1);
β;
RETURN($$1);
β;
! TERM T: F {*|/ F} ;
RECURSIVE RPTR(EXPR) PROCEDURE TERM;
α RPTR(EXPR) $$1; INTEGER I;
$$1←FACTOR;
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #TERM DO
α I←TOKEN_INDEX;
GGTOKEN; EXPR:NEXT[$$1]←FACTOR;
$$1←MAKE_CODE(I,2,$$1);
β;
RETURN($$1);
β;
RECURSIVE RPTR(EXPR) PROCEDURE FACTOR;
α RPTR(EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE #TOKEN OF
α
[REAL_TYPE]
[INT_TYPE]
α
$$1←MK_EXPR(TOKEN_PTR,TOKEN_INDEX);
GGTOKEN(FALSE);
β;
[ID_TYPE]
α
$$1←MK_EXPR(TOKEN_PTR,TOKEN_INDEX);
GGTOKEN(FALSE);
β;
[OPERATOR_TYPE]
CASE TOKEN_INDEX OF
α
[LPAREN_X]
α GGTOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")"
THEN WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP;
I2←I2+1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")" THEN
ERROR("MISMATCHED PAREN,WILL INSERT")
ELSE GGTOKEN(FALSE);
IF I2≠1 THEN $$1←MAKE_CODE(IMPLICIT_X,I2,$$1);
β;
[MAGNITUDE_X]
α GGTOKEN; $$1←EXP;
IF TOKEN="|"
THEN GGTOKEN(FALSE)
ELSE ERROR("MISMATCHED VERT BAR, WILL INSERT");
$$1←MAKE_CODE(MAGNITUDE_X,1,$$1);
β;
ELSE ERROR("UNEXPECTED TOKEN FOUND"&TOKEN)
β;
[RES_TYPE]
IF EQU(TOKEN,"BPARK")
THEN α $$1←MK_EXPR(F_BPARK,#FR);
GTOKEN(FALSE); β
ELSE IF EQU(TOKEN,"YPARK")
THEN α $$1←MK_EXPR(F_YPARK,#FR);
GTOKEN(FALSE); β
ELSE
α I←TOKEN_INDEX; GGTOKEN;
IF TOKEN≠"("
THEN ERROR("REQUIRE LEFT PAREN, WILL INSERT")
ELSE GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR("MISMATCHED PAREN, WILL INSERT")
ELSE GGTOKEN(FALSE);
$$1←MAKE_CODE(I,I2,$$1);
β;
ELSE ERROR("UNEXPECTED TOKEN FOUND")
β;
RETURN($$1);
β;
INTERNAL RPTR(TREE)PROCEDURE GTEXPR;
α RPTR(EXPR)$$1;
GGTOKEN;
$$1←EXP;
STOKEN←TRUE;
RETURN(NWTREE(EXPR:PTR[$$1],EXPR:TYPE[$$1]));
β;
END;